﻿#!/usr/local/bin/perl
################################################################################
# f2c.pl
# Description:  P4thコマンドテキスト・コンパイラ
#
# Author:       shozo fukuda
# Date:         Thu Feb  9 20:28:22 2006
# Last revised: $Date$
# Application:  Perl version 5.8.0
################################################################################

#<IMPORT>

($program) = ($0 =~ m#([^/\\]+)$#);
($exepath) = ($`);

#<GLOBAL>#######################################################################
# Function:     
# Description:  
# Dependencies: 
################################################################################
$current = 0;
$cp      = 0;
$cs      = "";

$np      = 1;
$ns      = sprintf("\t%4d, /*NAMELESS*/\n", 0);

$fno     = 0;
$w_list  = "";
$f_list  = "";
$f_tbl   = "";
$f_prot  = "";

$extern  = "";
$const   = "";

#<SUBROUTINE>###################################################################
# Function:     使用例の表示
# Description:  
# Dependencies: 
################################################################################
sub usage {
  print <<EOU
Usage: $program

EOU
}

#<SUBROUTINE>###################################################################
# Function:     エラーメッセージの表示
# Description:  
# Dependencies: 
################################################################################
sub error {
  my ($msg) = @_;
  print("error: $msg - $!\n\n");
  &usage();
  exit(1);
}

#<SUBROUTINE>###################################################################
# Function:     名前リスト構築
# Description:  FORTH文字列フォーマットで名前リストを構築します。
# Dependencies: 
################################################################################
sub word {
  my ($name) = @_;
  my $index = $np;

  return 0 if ($name eq 'NAMELESS'); 

  # 文字数をセット
  $len = length($name);

  # 文字列を分解
  @name = ();
  foreach (split('', $name)) {
    push(@name, /[\\'"\?]/ ? qq('\\$_') : qq('$_'));
  }
  
  # FORTH文字列フォーマットを構築
  $ns .= sprintf("\t%4d, %s,\n", $len, join(',', @name));
  
  $np += $len + 1;  
  return $index;
}

#<SUBROUTINE>###################################################################
# Function:     ワード登録
# Description:  ワードを辞書に登録します。
# Dependencies: 
################################################################################
sub compile {
  my ($name, $f_name, @prm) = @_;
  
  $cs .= sprintf("\t%4d, %4d, %s,\n", $current, word($name), join(",\t", $f_name, @prm));
  $current = $cp;
  $cp += 3 + @prm;

  return $current+2;
}

#<SUBROUTINE>###################################################################
# Function:     サブルーチン登録
# Description:  サブルーチンを辞書に登録します。
# Dependencies: 
################################################################################
sub subroutine {
  my ($f_name) = @_;
  
  $cs .= sprintf("\t            %s,\n", $f_name);
  
  return $cp++;
}

#<SUBROUTINE>###################################################################
# Function:     Cファンクション登録
# Description:  Cファンクションの識別コード、ジャンプテーブルを作成します。
# Dependencies: 
################################################################################
sub cfunc {
  my ($f_name, $func, $immediate) = @_;

  # ファンクション・テーブルを作成
  $f_list .= ($immediate) ? sprintf("\t%-16s = %4d | F_IMMEDIATE,\n", $f_name, $fno)
                          : sprintf("\t%-16s = %4d,\n", $f_name, $fno);
  $f_tbl  .= "\t$func,\n";
  $fno++;
  
  # 関数プロトタイプ宣言を作成
  $f_prot .= "void $func(P4th* p4th);\n";
}

#<MAIN>#########################################################################
# Function:     メインルーチン
# Description:  
# Dependencies: 
################################################################################
while (<>) {
  if (/forth\s+/) {
    $_ = $';
  
    if (/^CODE\s+(.*)\s+END-CODE/) {
      # プライマリ・ワードの構築
      ($name, $func) = split(' ', $1);
      $immediate = ($' =~ /IMMEDIATE/) ? 1 : 0;
  
      # サブルーチン、ワード識別子を作成
      $f_name = uc($func);
      $f_name =~ s/^F_/S_/;
      $w_name = uc($func);
      $w_name =~ s/^F_/P_/;

      # FORTH辞書を構築
      $w_val = compile($name, $f_name);

      $w_list .= sprintf("\t%-16s = %4d,\n", $w_name, $w_val);
      
      # ファンクション・テーブルを作成
      cfunc($f_name, $func, $immediate);
    }
    elsif (/^:\s+(.*)\s+;/) {
      # セカンダリ・ワードの構築
    }
    elsif (/^SUBR\s+/) {
      # サブルーチン・ワードの構築
      ($func) = split(' ', $');
      $immediate = ($' =~ /IMMEDIATE/) ? 1 : 0;
  
      # サブルーチン、ワード識別子を作成
      $f_name = uc($func);
      $f_name =~ s/^F_/S_/;
      $w_name = uc($func);
      $w_name =~ s/^F_/P_/;

      # FORTH辞書を構築
      $w_val = subroutine($f_name);

      $w_list .= sprintf("\t%-16s = %4d,\n", $w_name, $w_val);
      
      # ファンクション・テーブルを作成
      cfunc($f_name, $func, $immediate);
    }
    elsif (/^CFUNC\s+/) {
      # ファンクションの登録
      ($func) = split(' ', $');
  
      # ファンクション識別子を作成
      $f_name = uc($func);
      $f_name =~ s/^F_/S_/;

      # ファンクション・テーブルを作成
      cfunc($f_name, $func, 0);
    }
  }
  elsif (/P4thConst\s+(\w+)\s*\[\s*\]/) {
    $extern .= sprintf("extern P4thConst %s[];\n", $1);
    $const  .= sprintf("\t%s,\n", $1);
  }
}

$date = scalar(localtime);


open(DST, ">Dic.h");
print DST <<SRC;
/***  File Header  ************************************************************/
/**
* @file Dic.h
*
* P4thディクショナリ
* @author shozo fukuda
* @date   作成 $date
* @date   修正 \$Date:\$
* System  Generic <br>
*
*******************************************************************************/
#ifndef _DIC_H
#define _DIC_H

/*******************************************************************************
* IMPORTS:
*******************************************************************************/
#include "charm.h"
#include "P4th.h"

/*******************************************************************************
* CONSTANT:
*******************************************************************************/
enum {
$w_list};

enum {
$f_list};

const long FENCE = $current;

/*******************************************************************************
* TYPE:
*******************************************************************************/

/*******************************************************************************
* MACRO:
*******************************************************************************/
#define STATE     (p4th->iState)

#define IP        (p4th->iIP)
#define W         (p4th->iW)

#define TOS       (p4th->At(1))
#define S2        (p4th->At(2))
#define S3        (p4th->At(3))
#define S4        (p4th->At(4))
#define S(d)      (p4th->At(d))
#define DEPTH     (p4th->Depth())

#define RTOS      (p4th->RAt(1))
#define R2        (p4th->RAt(2))
#define R3        (p4th->RAt(3))
#define R4        (p4th->RAt(4))

#define PUSH(x)   (p4th->Push(x))
#define POP()     (p4th->Pop())
#define RPUSH(x)  (p4th->RPush(x))
#define RPOP()    (p4th->RPop())

#define CURRENT   (p4th->iCurrent)
#define BUILD(x)  (p4th->Build(x))
#define CODE(a)   (p4th->Memory(a))
#define HERE()    (p4th->Here())
#define OFFS(a)   (p4th->Offs(a))

#define BEG_SELF  (p4th->BegSelf())
#define END_SELF  (p4th->EndSelf())

#endif /* _DIC_H */
SRC

open(DST, ">Dic.cpp");
print DST <<SRC
/***  File Header  ************************************************************/
/**
* @file Dic.cpp
*
* P4thディクショナリ
* @author shozo fukuda
* @date   作成 $date
* @date   修正 \$Date:\$
* System   Generic <br>
*
*******************************************************************************/

/*******************************************************************************
* IMPORTS:
*******************************************************************************/
#include "Dic.h"  /* 呼出用 */

/*******************************************************************************
* CONSTANT:
*******************************************************************************/

/*******************************************************************************
* TYPE:
*******************************************************************************/

/*******************************************************************************
* REGULAR C-FUNCTION:
*******************************************************************************/
$f_prot
/*******************************************************************************
* GLOBAL VARIABLE:
*******************************************************************************/
static P4thFunc _func[$fno] = {
$f_tbl};
P4thFunc* P4th::_Func = _func;

static UCHAR _name[$np] = {
$ns};
UCHAR* P4th::_Name = _name;
const long P4th::_NameFence = $np;

static Code _code[$cp] = {
$cs};
Code* P4th::_Code = _code;
const long P4th::_CodeFence = $cp;


$extern
static P4thConst* _const[] = {
$const
  0
};
P4thConst** P4th::_Const = _const;

/* end of Dic.cpp */
SRC

__END__ # f2c.pl
